home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
uclp13.zip
/
CLIPOBJ.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-09-20
|
24KB
|
957 lines
UNIT ClipObj;
Interface
USES WinTypes, WinProcs, WObjects, Strings,Win31,WinDOS;
{$D ClipObj Copyright (c) 1992 Doug Overmyer}
const
st_OK = 1;
st_ClipFailure = 2;
st_NoMem = 3;
cc_CopyAll = 99;
type
PClipItem = ^TClipItem;
TClipItem = object(TObject)
CHandle:THandle;
CName:PChar;
CFormat:Word;
constructor Init(NewCHandle:THandle;NewCName:PChar;NewCFormat:Word);
destructor Done;virtual;
end;
PClipObj = ^TClipObj;
TClipObj = OBJECT(TObject)
constructor Init(hW:HWnd;var Stat:Word;SRect:TRect);
procedure GetClip(hW : hWnd; var Stat : Word);
destructor Done; Virtual;
procedure CopyClip(hW : hWnd;Clip:PClipItem);
procedure CopyClipS(hW : hWnd;I:PMultiSelRec);
procedure RenderSelf(DC:hDC;hWin:HWnd;IsZ:Bool);
procedure RenderSelfZ(DC:hDC;hWin:HWnd;IsZ:Bool);
procedure RedrawSelf(DC:hDC;hWin:HWnd;IsZ:Bool);
function GetStatus: Word;
function GetPal: hPalette;
function GetDIB: THandle;
function GetPICT: THandle;
function GetClips:PCollection;
procedure GetInfo(Info:PChar;Len:Integer);
procedure SetIsPrefText(Choice:Bool);
procedure ToggleIsPrefText;
procedure GetFormats(Buf:PChar);
procedure GetClipFormatName(nf:Integer; nN:PChar;Count:Word);
Private
Clips : PCollection;
name : ARRAY[0..80] OF Char;
hDIB : THandle;
hPal : hPalette;
hPICT : THandle;
hText :THandle;
hNative :THandle;
hBMP :HBitmap;
hDisp : HBitmap;
hDispZ : hBitmap;
Status :Word;
IsPrefText:Bool;
SR : TRect; {Sizing Rectangle}
end;
{**************************** Implementation **********************}
Implementation
type
LongType = record
CASE Word OF
0: (Ptr: Pointer);
1: (Long: Longint);
2: (Lo: Word;
Hi: Word);
end;
procedure AHIncr; far; external 'KERNEL' index 114;
function _hRead(hFile:Integer;Buffer:PChar;dwBytes:LongInt):LongInt;far; external 'KERNEL';
function _hWrite(hFile:Integer;Buffer:PChar;dwBytes:LongInt):LongInt;far; external 'KERNEL';
{************************* Functions *******************************}
function LongMin(A, B: LongInt): LongInt;
begin
if A < B then LongMin := A else LongMin := B;
end;
function LongMax(A, B: LongInt): LongInt;
begin
if A > B then LongMax := A else LongMax := B;
end;
function DIBSize(Width,Height:LongInt;Res:Integer):LongInt;
begin
DIBSize := (((LongInt(Width)*RES+31) div 32) * 4) * Height;
end;
function CopyGHND(hGM1:THandle):THandle;
var
Size:LongInt;
hGM2:THandle;
pGM2,pGM1:Pointer;
begin
CopyGHND := 0;
Size :=GlobalSize(hGM1);
pGM1 := GlobalLock(hGM1);
IF pGM1 = NIL then Exit;
hGM2 :=GlobalAlloc(GHND,Size);
pGM2 := GlobalLock(hGM2);
if pGM2 <> nil then
hmemCpy(pGM2,pGM1,Size);
GlobalUnlock(hGM2);
CopyGHND := hGM2;
end;
function GetDIBColorCnt(bi:PBitmapInfo):Word;
begin
GetDIBColorCnt := bi^.bmiHeader.biClrUsed;
if bi^.bmiHeader.biClrUsed = 0 then
if bi^.bmiHeader.biBitCount <> 24 then
GetDIBColorCnt:= 1 shl bi^.bmiHeader.biBitCount;
end;
function GetDIBBits(pDIB:Pointer):Pointer;
var
bi:PBitmapInfo;
cPalColors:Word;
begin
GetDIBBits := NIL;
bi := pDIB;
cPalColors := GetDIBColorCnt(bi);
GetDIBBits := Ptr(Seg(bi^),
ofs(bi^)+sizeof(TBitmapInfoHeader)+cPalColors*sizeof(TRGBQuad));
end;
function GetDIBPal(bi:PBitmapInfo):HPalette;
var
PalSize,N,cPalColors: Word;
pal : PLogPalette;
begin
GetDIBPal := 0;
cPalColors :=GetDIBColorCnt(bi);
IF cPalColors = 0 then Exit;
PalSize := SizeOf(TLogPalette)+Pred(cPalColors)*sizeof(TPaletteEntry);
GetMem(pal, PalSize);
pal^.palVersion := $300;
pal^.palNumEntries := cPalColors;
FillChar(pal^.palPalEntry, cPalColors *sizeof(TPaletteEntry), 0);
FOR N := 0 TO pred(cPalColors) DO
WITH pal^.palPalEntry[N], bi^.bmiColors[N] DO
begin
peRed := rgbRed;
peGreen := rgbGreen;
peBlue := rgbBlue
end;
GetDibPal := CreatePalette(pal^);
FreeMem(pal, PalSize);
end;
function CopyPal(hP:hPalette):hPalette;
var
Pal : PLogPalette;
cPalColors:Word;
begin
CopyPal := 0;
if hP = 0 then Exit;
GetObject(hP,2,@cPalColors);
GetMem(Pal, sizeof(TLogPalette) + pred(cPalColors)*sizeof(TPaletteEntry));
pal^.palVersion := $300;
pal^.palNumEntries := cPalColors;
GetPaletteEntries(hP, 0, cPalColors,pal^.palPalEntry);
CopyPal := CreatePalette(pal^);
FreeMem(Pal, sizeof(TLogPalette)+pred(cPalColors)*sizeof(TPaletteEntry));
end;
function CopyBMP(hB1:HBitmap;DC:hDC): hBitmap;
var
cBits,ret:LongInt;
hBits:THandle;
pBits:Pointer;
tb:TBitmap;
hB2:HBitmap;
begin
CopyBMP := 0;
if hB1 = 0 then Exit;
GetObject(hB1,sizeof(TBitmap),@tb);
cBits := LongInt(tb.bmWidthBytes)*tb.bmHeight *tb.bmPlanes;
hbits :=GlobalAlloc(GHND,cBits);
pBits := GlobalLock(hBits);
ret :=GetBitmapBits(hB1,cBits,pBits);
hB2 := CreateCompatibleBitmap(DC,tb.bmWidth,tb.bmHeight);
ret :=SetBitmapBits(hB2,cBits,pBits);
GlobalUnlock(hBits);
GlobalFree(hBits);
CopyBMP := hB2;
end;
function ScaleBMP(hB1:HBitmap;hP:HPalette;DC:hDC;SR:TRect): hBitmap;
var
cBits,ret:LongInt;
Bits:THandle;
pBits:Pointer;
tb:TBitmap;
hB2,oB1,oB2:HBitmap;
RC:TRect;
MaxXY,X,Y:LongInt;
MemDC1,MemDC2:HDC;
oP:HPalette;
begin
ScaleBMP := 0;
if hB1 = 0 then Exit;
GetObject(hB1,sizeof(TBitmap),@tb);
X:=tb.bmWidth;Y:=tb.bmHeight;
MaxXY:=LongMax(X,Y);
SetRect(RC,0,0,SR.Right*X div MaxXY,
SR.Bottom*Y div MaxXY);
MemDC1:= CreateCompatibleDC(DC);
MemDC2:= CreateCompatibleDC(DC);
hB2:=CreateCompatibleBitmap(DC,RC.Right,RC.Bottom);
oB2:=SelectObject(MemDC2,hB2);
oB1:=SelectObject(MemDC1,hB1);
if hP > 0 then oP := SelectPalette(memDC2,hP,False);
RealizePalette(memDC2);
SetStretchBltMode(memDC2,stretch_deletescans);
StretchBlt(memDC2,0,0,RC.Right,RC.Bottom,memDC1,0,0,
X,Y,SRCCopy);
if hP > 0 then SelectPalette(memDC2,oP,False);
SelectObject(memDC1,oB1);
SelectObject(memDC2,oB2);
DeleteDC(memDC1);
DeleteDC(memDC2);
ScaleBMP :=hB2;
end;
function BMPtoDIB(hB:HBitmap;hP:HPalette;DC:HDC):THandle;
var
hbi:THandle;
bi:PBitmapInfo;
tb:TBitmap;
pBits:Pointer;
hBits:THandle;
cSize:LongInt;
oP:HPalette;
bRES,cColor:Integer;
begin
if hP <> 0 then
begin
oP :=SelectPalette(DC,hP,false);
RealizePalette(DC);
end
else op := 0;
GetObject(hB,sizeof(TBitmap),@tb);
bRES := tb.bmPlanes*tb.bmBitsPixel;
cColor := 0;
if bRES < 24 then cColor := 1 shl bRES;
cSize :=DIBSize(tb.bmWidth,tb.bmHeight,bRes);
hbi :=GlobalAlloc(GHND,sizeof(TBitmapInfoHeader)+cColor*sizeof(TRGBQuad)+cSize);
bi := GlobalLock(hbi);
with bi^.bmiHeader do
begin
biSize:= sizeof(TBitmapInfoHeader);
biWidth :=tb.bmWidth;
biHeight := tb.bmHeight;
biPlanes := 1;
biBitCount := bRES;
biCompression := BI_RGB;
end;
pBits:=Ptr(Seg(bi^),
ofs(bi^)+sizeof(TBitmapInfoHeader)+cColor*sizeof(TRGBQuad));
GetDIBits(DC,hB,0,tb.bmHeight,pBits,bi^,DIB_RGB_Colors);
GlobalUnlock(hbi);
BMPtoDIB := hbi;
if hP > 0 then selectPalette(DC,oP,false);
end;
function DIBtoBMP(H:THandle;hW:HWnd;DC1:hDC):hBitmap;
var
bi:PBitmapInfo;
hP,oP:HPalette;
bits:Pointer;
DC2:hDC;
begin
DIBtoBMP := 0;
if H = 0 then Exit;
bi := GlobalLock(H);
if bi = nil then Exit;
hP := GetDibPal(bi);
if DC1 = 0 then
DC2 := GetDC(hW)
else DC2 := DC1;
if hP > 0 then oP := SelectPalette(DC2,hP,False);
RealizePalette(DC2);
bits := GetDIBBits(bi);
DIBtoBMP:= CreateDIBitmap(DC2, bi^.bmiHeader,
cbm_Init, bits, bi^, dib_RGB_Colors);
GlobalUnlock(H);
if hP > 0 then SelectPalette(DC2,oP,False);
DeleteObject(hP);
if DC1 = 0 then
ReleaseDC(hW,DC2);
end;
function DIBtoBMPScaled(H:THandle;hW:HWnd;SR:TRect):hBitmap;
var
bi:PBitmapInfo;
hP,oP:HPalette;
bits:Pointer;
DC:hDC;
hB,oB:HBitmap;
RC:TRect;
MaxXY,X,Y:Word;
MemDC:HDC;
begin
hP:= 0;
DIBtoBMPScaled := 0;
if H = 0 then Exit;
bi := GlobalLock(H);
if bi = nil then Exit;
X:=bi^.bmiheader.biWidth;Y:=bi^.bmiheader.biHeight;
MaxXY:=LongMax(X,Y);
SetRect(RC,0,0,SR.Right * X div MaxXY,SR.Bottom * Y div MaxXY);
hP := GetDibPal(bi);
DC := GetDC(hW);
MemDC:= CreateCompatibleDC(DC);
hB:=CreateCompatibleBitmap(DC,RC.Right,RC.Bottom);
oB:=SelectObject(MemDC,hB);
if hP > 0 then oP := SelectPalette(memDC,hP,False);
RealizePalette(memDC);
bits := GetDIBBits(bi);
SetStretchBltMode(memDC,stretch_deletescans);
StretchDIBits(memDC,0,0,RC.Right,RC.Bottom,0,0,
X,Y,bits, bi^, dib_RGB_Colors,SRCCopy);
GlobalUnlock(H);
if hP > 0 then SelectPalette(memDC,oP,False);
if hP > 0 then DeleteObject(hP);
SelectObject(memDC,oB);
DeleteDC(memDC);
DIBtoBMPScaled :=hB;
ReleaseDC(hW,DC);
end;
function CopyPICT(H:THandle):THandle;
var
mi:PMetaFilePict;
hMFP:THandle;
pMFP:PMetaFilePict;
begin
CopyPICT := 0;
mi := GlobalLock(H);
If mi = nil then EXIT;
hMFP := GlobalAlloc(GHND,sizeof(TMetaFilePict));
pMFP := GlobalLock(hMFP);
pMFP^.mm := mi^.mm;
pMFP^.xEXT := mi^.xEXT;
pMFP^.yEXT := mi^.yEXT;
pMFP^.hMF := CopyMetaFile(mi^.hMF,nil);
GlobalUnlock(H);
GlobalUnlock(hMFP);
CopyPICT := hMFP;
end;
procedure DelPICT(H:THandle);
var
pMFP:PMetaFilePict;
begin
if H = 0 then Exit;
pMFP := GlobalLock(H);
if pMFP = nil then Exit;
DeleteMetaFile(pMFP^.hMF);
GlobalUnlock(H);
GlobalFree(H);
end;
procedure GetPICTSize(H:THandle;DC:HDC;HWin:HWnd;var X,Y:LongInt);
var
om:Integer;
mfp:PMetaFilePict;
XP,YP:TPoint;
CR:TRect;
begin
XP.X := 0;XP.Y:=0;YP.X:=0;YP.Y:= 0;
GetClientRect(HWin,CR);
if H = 0 then Exit;
mfp := GlobalLock(H);
if mfp = nil then Exit;
if (mfp^.mm = MM_ISOTROPIC) OR (mfp^.mm = MM_ANISOTROPIC) then
om := SetMapMode(DC,MM_HIMETRIC)
else
om := SetMapMode(DC,mfp^.mm);
XP.x := mfp^.xExt;
YP.y := mfp^.yExt;
SetViewportOrg(DC,0,0);
LPtoDP(DC,XP,1);LPtoDP(DC,YP,1); {get nominal size of image}
SetMapMode(DC,om);
GlobalUnlock(H);
X:=abs(XP.x); Y:= abs(YP.Y);
if (X=0) or (Y=0) then
begin
X:=CR.Right;Y:=CR.Bottom;
end;
end;
procedure RenderPICT(H:THandle;DC:HDC;HWin:HWnd;SR:TRect);
var
om:Integer;
mfp:PMetaFilePict;
X,Y:LongInt;
MaxXY:LongInt;
begin
if H = 0 then Exit;
X:=SR.Right;Y:=SR.Bottom;
MaxXY:=LongMax(X,Y);
mfp := GlobalLock(H);
om := SetMapMode(DC,mfp^.mm);
SetViewportOrg(DC,0,0);
SetViewPortExt(DC,X,Y);
PlayMetaFile(DC,mfp^.hMF);
GlobalUnlock(H);
SetMapMode(DC,oM);
end;
function PICTtoBMP(H:THandle;DC:HDC;HWin:HWnd;SR:TRect):HBitmap;
var
RC:TRect;
om:Integer;
hB,oB:HBitmap;
MemDC:hDC;
X,Y,Size:LongInt;
MaxXY:LongInt;
begin
PICTtoBMP := 0;
if H = 0 then Exit;
GetPICTSize(H,DC,HWin,X,Y);
MaxXY:=LongMax(X,Y);
if SR.Right > 0 then
SetRect(RC,0,0,SR.Right * X div MaxXY,SR.Bottom * Y div MaxXY)
else
SetRect(RC,0,0,X,Y);
memDC := CreateCompatibleDC(DC);
hB := CreateCompatibleBitmap(DC,RC.Right,RC.Bottom);
oB:=SelectObject(memDC,hB);
FillRect(memDC,RC,GetStockObject(WHITE_BRUSH));
RenderPict(H,memDC,HWin,RC);
SelectObject(memDC,oB);
DeleteDC(memDC);
PICTtoBMP:= hB;
end;
{************************* TClipObj *******************************}
constructor TClipObj.Init(hW:hWnd;var Stat:Word;SRect:TRect);
var
hO:hWnd;
hM:THandle;
begin
TObject.Init;
hText := 0;hPal := 0;hDIB := 0;hPICT := 0;hNative := 0;
hBMP := 0;hDISP:=0;hDispZ:= 0;Strcopy(Name,'');hM:=0;hO:=0;
SR:=SRect;
IsPrefText := True;
hO:=GetclipBoardOwner;
if hO <> 0 then
hM:=GetClassWord(hO,GCW_HMODULE);
if hM <> 0 then
GetModuleFileName(hM,name,sizeof(name));
filesplit(name,nil,name,nil);
GetClip(hW,Stat);
if Stat <> id_Ok then Fail;
end;
procedure TClipObj.GetClip(hW : hWnd;var Stat:Word);
var
H : THandle;
hB : HBitmap;
DC : hDC;
nF :Word;
nN :Array[0..50] of Char;
cF :Integer;
nH :THandle;
Indx :Integer;
Clip :PClipItem;
begin
nF := 0;H := 0;StrCopy(nN,'');
Stat := st_ClipFailure;
if NOT OpenClipboard(hW) then EXIT;
Stat := st_OK;
Clips := New(PCollection,Init(10,10));
cF :=CountClipboardFormats;
for Indx := 0 to Pred(cF) do
begin
nF := EnumClipboardFormats(nF);
StrCopy(nN,'');
GetClipFormatName(nf,@nN,50);
H := GetClipboardData(nF);
if H = 0 then
{ignore these, usually owner-draw}
else if (StrLIComp(nN,'MGX',3) = 0) then
{lets skip this one - causes problems}
else
begin
case nF of
CF_DIB:
begin
nH :=CopyGHND(H);
hDIB := nH;
end;
CF_PALETTE:
begin
nH := CopyPal(H);
hPAL := nH;
end;
CF_BITMAP:
begin
DC := GetDC(HW);
nH := CopyBMP(H,DC);
ReleaseDC(hW,DC);
hBMP := nH;
end;
CF_METAFILEPICT:
begin
nH := CopyPICT(H);
hPICT := nH;
end;
CF_TEXT:
begin
nH :=CopyGHND(H);
hText:= nH;
end;
else
begin
nH :=CopyGHND(H);
if StrIComp('Native',nN) = 0 then hNative := nH;
end;
end;
Clips^.Insert(New(PClipItem,Init(nH,nN,nF)));
end;
end;
CloseClipboard;
if Stat = st_OK then {Build graphic thumbnail}
begin
if (hDIB > 0) then
hDisp:=DIBtoBMPScaled(hDIB,hW,SR)
else if (hBMP>0) then
begin
DC:=GetDC(HW);
hDISP:=ScaleBMP(hBMP,hPAL,DC,SR);
releaseDC(HW,DC);
end
else if (hPict>0) then
begin
DC:=GetDC(HW);
hDISP:= PICTtoBMP(hPICT,DC,hW,SR);
releaseDC(HW,DC);
end;
end
else {if failure, dealloc objects}
for Indx := 0 to Pred(Clips^.Count) do
begin
Clip := Clips^.At(Indx);
case Clip^.CFormat of
CF_PALETTE:
DeleteObject(Clip^.CHandle);
CF_BITMAP:
DeleteObject(Clip^.CHandle);
CF_METAFILEPICT:
DelPICT(Clip^.CHandle);
else
GlobalFree(Clip^.CHandle);
end;
end;
Status := Stat;
end;
procedure TClipObj.GetClipFormatName(nf:Integer;nN:PChar;Count:Word);
begin
case nF of
cf_Text:StrCopy(nN,'Text');
cf_Bitmap:Strcopy(nN,'Bitmap');
cf_MetaFilePict:StrCopy(nN,'Picture');
cf_Sylk:StrCopy(nN,'Sylk');
cf_DIF:StrCopy(nN,'DIF');
cf_TIFF:StrCopy(nN,'TIFF');
cf_OEMText:StrCopy(nN,'OEM Text');
cf_DIB:StrCopy(nN,'DIB Bitmap');
cf_Palette:StrCopy(nN,'Palette');
cf_PenData:StrCopy(nN,'Pen Data');
cf_RIFF:StrCopy(nN,'RIFF');
cf_Wave:StrCopy(nN,'Wave');
cf_OwnerDisplay:StrCopy(nN,'Owner-Display');
cf_DspText:StrCopy(nN,'Disp Text');
cf_DSPMetaFilePict:StrCopy(nN,'Disp Picture');
cf_DSPBitmap:StrCopy(nN,'Disp Bitmap');
else
GetClipboardFormatName(nF,nN,50);
end;
end;
procedure TClipObj.CopyClipS(hW : hWnd;I:PMultiSelRec);
var
cSize : LongInt;
Clip:PClipItem;
Indx,Indx2:Integer;
Str:PChar;
begin
Status := st_ClipFailure;
if NOT OpenClipboard(hW) then EXIT;
EmptyClipboard;
if I^.Count = cc_CopyAll then
for Indx := 0 to Pred(Clips^.Count) do
begin
Clip := Clips^.At(Indx);
CopyClip(hW,Clip);
end
else
for Indx := 1 to I^.Count do
begin
Clip:= Clips^.At(I^.Selections[Pred(Indx)]);
CopyClip(hW,Clip);
end;
CloseClipboard;
end;
procedure TClipObj.CopyClip(hW : hWnd;Clip:PClipItem);
var
DC : hDC;
oP : hPalette;
cSize : LongInt;
nH:THandle;
begin
case Clip^.CFormat of
CF_DIB:
nH :=CopyGHND(Clip^.CHandle);
CF_PALETTE:
nH := CopyPal(Clip^.CHandle);
CF_BITMAP:
begin
DC := GetDC(HW);
if hPAL > 0 then oP:=SelectPalette(DC,hPAL,false);
RealizePalette(DC);
nH := CopyBMP(Clip^.CHandle,DC);
if hPAL > 0 then SelectPalette(DC,oP,false);
ReleaseDC(hW,DC);
end;
CF_METAFILEPICT:
nH := CopyPICT(Clip^.CHandle);
CF_TEXT:
nH :=CopyGHND(Clip^.CHandle);
else
nH :=CopyGHND(Clip^.CHandle);
end;
SetClipboardData(Clip^.CFormat,nH);
end;
destructor TClipObj.Done;
var
Indx:Integer;
Clip:PClipItem;
begin
for Indx := 0 to Pred(Clips^.Count) do
begin
Clip := Clips^.At(Indx);
case Clip^.CFormat of
CF_DIB:
GlobalFree(Clip^.CHandle);
CF_PALETTE:
DeleteObject(Clip^.CHandle);
CF_BITMAP:
DeleteObject(Clip^.CHandle);
CF_METAFILEPICT:
DelPICT(Clip^.CHandle);
CF_TEXT:
GlobalFree(Clip^.CHandle);
else
GlobalFree(Clip^.CHandle);
end;
end;
if hDisp >0 then DeleteObject(hDISP);
if hDispZ >0 then DeleteObject(hDISPZ);
Dispose(Clips,Done);
TObject.Done;
end;
procedure TClipObj.RenderSelf(DC:hDC;hWin:HWnd;IsZ:Bool);
var
Clip:PClipItem;
hP,oP:hPalette;
tb:TBitmap;
oB:HBitmap;
pBits:Pointer;
bi:PBitmapInfo;
pT:Pointer;
CR:TRect;
memDC:hDC;
Indx:Integer;
Buf:PChar;
begin
if Clips^.Count = 0 then Exit;
if ((hText=0) and (hDisp=0)) then
begin
GetMem(Buf,72*Clips^.Count+sizeof(name)); StrCopy(Buf,'');
StrCat(StrCat(StrCat(StrCat(Buf,'Src:'),StrLower(name)),' '),#13#10);
for Indx := 0 to Pred(Clips^.Count) do
begin
Clip := Clips^.At(Indx);
StrCat(StrCat(Buf,Clip^.CName),#13#10);
end;
GetClientRect(hWin,CR);
SetBkMode(DC,transparent);
DrawText(DC,Buf,-1,CR,DT_Left);
FreeMem(Buf,72*Clips^.Count+sizeof(name));
end
else if ((hText > 0) and IsPrefText) or
(hDisp=0) then
begin
pT := GlobalLock(hText);
GetClientRect(hWin,CR);
SetBkMode(DC,transparent);
DrawText(DC,pT,-1,CR,DT_Left);
GlobalUnlock(hText);
end
else if hDISP > 0 then
begin
if IsZ then
RenderSelfZ(DC,hWin,IsZ)
else
begin
if hPal > 0 then oP := SelectPalette(DC,hPal,False);
if hPal > 0 then RealizePalette(DC);
GetObject(hDISP,sizeof(TBitmap),@tb);
memDC:=CreateCompatibleDC(DC);
oB:=SelectObject(memDC,hDISP);
BitBlt(DC,0,0,tb.bmWidth,tb.bmHeight,memDC,0,0,SRCCOPY);
SelectObject(memDC,oB);
DeleteDC(memDC);
if hPal > 0 then SelectPalette(DC,oP,False);
end;
end;
end;
procedure TClipObj.RenderSelfZ(DC:hDC;hWin:HWnd;IsZ:Bool);
var
hP,oP:hPalette;
tb:TBitmap;
hB,oB:HBitmap;
pBits:Pointer;
bi:PBitmapInfo;
pT:Pointer;
CR:TRect;
memDC:hDC;
begin
if hDispZ = 0 then
begin
if (hDIB > 0) then
hDispZ:=DIBtoBMP(hDIB,hWin,DC)
else if (hBMP>0) then
hDispZ:=CopyBMP(hBMP,DC)
else if (hPict>0) then
begin
SetRect(CR,0,0,0,0);
hDispZ:= PICTtoBMP(hPICT,DC,hWIN,CR);
end;
end;
if hDispZ > 0 then
begin
if hPal > 0 then oP := SelectPalette(DC,hPal,False);
if hPal > 0 then RealizePalette(DC);
GetObject(hDispZ,sizeof(TBitmap),@tb);
memDC:=CreateCompatibleDC(DC);
oB:=SelectObject(memDC,hDispZ);
BitBlt(DC,0,0,tb.bmWidth,tb.bmHeight,memDC,0,0,SRCCOPY);
SelectObject(memDC,oB);
DeleteDC(memDC);
if hPal > 0 then SelectPalette(DC,oP,False);
end;
end;
procedure TClipObj.RedrawSelf(DC:hDC;hWin:HWnd;IsZ:Bool);
var
pBits:Pointer;
bi:PBitmapInfo;
pT:Pointer;
CR:TRect;
tb:TBitmap;
memDC:hDC;
oB:HBitmap;
Clip:PClipItem;
Indx:Integer;
Buf:PChar;
begin
if ((hText=0) and (hDisp=0)) then
begin
GetMem(Buf,72*Clips^.Count+25); StrCopy(Buf,'');
StrCat(StrCat(StrCat(StrCat(Buf,'Src:'),StrLower(name)),' '),#13#10);
for Indx := 0 to Pred(Clips^.Count) do
begin
Clip := Clips^.At(Indx);
StrCat(StrCat(Buf,Clip^.CName),#13#10);
end;
GetClientRect(hWin,CR);
SetBkMode(DC,transparent);
DrawText(DC,Buf,-1,CR,DT_Left);
FreeMem(Buf,72*Clips^.Count+25);
end
else if ((hText > 0) and IsPrefText) or
(hDisp=0) then
begin
pT := GlobalLock(hText);
GetClientRect(hWin,CR);
SetBkMode(DC,transparent);
DrawText(DC,pT,-1,CR,DT_Left);
GlobalUnlock(hText);
end
else if hDISP > 0 then
begin
if IsZ then
RenderSelfZ(DC,hWin,IsZ)
else
begin
GetObject(hDISP,sizeof(TBitmap),@tb);
memDC:=CreateCompatibleDC(DC);
oB:=SelectObject(memDC,hDISP);
BitBlt(DC,0,0,tb.bmWidth,tb.bmHeight,memDC,0,0,SRCCOPY);
SelectObject(memDC,oB);
DeleteDC(memDC);
end;
end;
end;
function TClipObj.GetStatus : Word;
begin
GetStatus := Status;
end;
function TClipObj.GetPal : hPalette;
begin
GetPal := hPal;
end;
function TClipObj.GetDIB : THandle;
begin
GetDIB := hDIB;
end;
function TClipObj.GetPICT : THandle;
begin
GetPICT := hPICT;
end;
procedure TClipObj.GetInfo(Info:PChar;Len:Integer);
type
ORec = Record
Size:Word;
Width:Word;
Height:Word;
Res:Word;
end;
PRec = Record
Size:Word;
end;
var
Size:LongInt;
H : THandle;
bi : PBitmapInfo;
O :ORec;
P :PRec;
Buf :Array[0..100] of Char;
pMFP :PMetaFilePict;
TB :TBitmap;
begin
fillchar(O,sizeOf(ORec),0);
fillchar(P,sizeof(PRec),0);
StrCopy(Info,''); StrCopy(Buf,'');
H := GetDIB;
if H <> 0 then
begin
bi := GlobalLock(H);
if bi <> nil then
begin
with bi^.bmiHeader, O do
if bi <> nil then
begin
width := biWidth;
Height := biHeight;
Res := biBitCount;
end;
GlobalUnlock(hDIB);
O.Size := GlobalSize(hDIB) div 1024;
wvsprintf(Buf,'DIB:%uK %u*%u*%u',O) ;
StrCat(Info,Buf);
end;
end;
if hPICT <> 0 then
begin
pMFP := GlobalLock(hPICT);
P.Size := GlobalSize(pMFP^.hMF) div 1024;
GlobalUnlock(hPICT);
wvsprintf(Buf,' PICT:%iK',P);
StrCat(Info,Buf);
end;
if hNative <> 0 then
begin
P.Size := GlobalSize(hNative) div 1024;
wvsprintf(Buf,' Native:%iK',P);
StrCat(Info,Buf);
end;
if hText > 0 then
begin
P.Size := GlobalSize(hText) ;
if P.Size > 1024 then
begin
P.Size := P.Size div 1024;
wvsprintf(Buf,' Text:%iK',P);
end
else
wvsprintf(Buf,' Text:%i Bytes',P);
StrCat(Info,Buf);
end;
if hBMP > 0 then
begin
GetObject(hBMP,sizeof(TBitmap),@tb);
with TB, O do
begin
width := bmWidth;
Height := bmHeight;
Res := bmPlanes;
Size := bmplanes*(Muldiv(height,width,1024));
end;
wvsprintf(Buf,' BMP:%uK %u*%u*%u',O) ;
StrCat(Info,Buf);
end;
end;
procedure TClipObj.SetIsPrefText(Choice:Bool);
begin
IsPrefText := Choice;
end;
procedure TClipObj.ToggleIsPrefText;
begin
IsPrefText := not IsPrefText;
end;
procedure TClipObj.GetFormats(Buf:PChar);
begin
if Buf <> nil then
begin
if (hDisp>0) and (hText>0) then
StrCopy(Buf,'*')
else
StrCopy(Buf,'');
end;
end;
function TClipObj.GetClips:PCollection;
begin
GetClips := Clips;
end;
{******************************** TClipItem ********************}
constructor TClipItem.Init(NewCHandle:THandle;NewCName:PChar;NewCFormat:Word);
begin
CHandle := NewCHandle;
CName :=StrNew(NewCName);
CFormat := NewCFormat;
end;
destructor TClipItem.Done;
begin
StrDispose(CName);
end;
end.